Technotools/Technotools (Chestnut CD-ROM)(1993).ISO/lang_oth/mini4th/mini.a86

Text File | 1988-08-08 | 22KB | 1,213 lines

; MINIFORTH  - Copyright 1988 by Ted Beach
;                                5112 Williamsburg Blvd.
;                                Arlington VA, 22207
;                 703-237-0295

; This is a VERY minimum version of FORTH that has several innovations -
; First, mini makes extensive use of TO variables, particularly as USER
; variables : BASE, >IN, COMPILING (STATE), S0, R0, BLK, BLOCK, etc.
; Second, there is incorporated a mechanism whereby conditionals (IF, THEN
; ELSE, BEGIN, UNTIL, etc.) can be executed directly from the keyboard with-
; out having to create a word (sometimes a dummy word) to compile them in.
; Simply key in the words as needed, then add a semicolon. The structure
; will execute at HERE then be discarded. Should you ever make an error while
; compiling from the keyboard, your mistake will be automatically erased --
; you won't find the dictionary garbaged up with a partially compiled word.
; Source code MUST BE ASSEMBLED WITH A86 - make needed changes if you
; want to use MASM (ugh!).
; The file named MINI.MIN has certain needed structures. You will have to
; enter these from the keyboard. In order to save the extended version, run
; mini under DEBUG. Then, just before leaving mini, enter "HERE  .H"
; Note the number printed, type "BYE", then from DEBUG change CX to the number
; printed. Use DEBUG's W command to Write the program to disk.

;          ***************** NOTE *******************

; You are free to use this copyrighted material for your own personal
; needs. Commercial use is prohibited without the consent of the copyright
; holder. Contact the author at the address above for additional information.
; There is already available version 1.5 which adds a second (short) machine
; stack to help certain operations. Tutorial material is available on learning
; how to use miniforth. For those used to FORTH, this listing and the MINI.MIN
; file should provide adequate information on how to extend miniforth.

;         *******************************************

HEAD    MACRO
    DW LINK
    LINK=$-2
    DB #1+080
    DB #2
#EM

HEADI    MACRO
    DW LINK
    LINK=$-2
    DB #1+0C0
    DB #2
#EM

COLON    MACRO
    CALL DOCOLON
#EM
NEXT    MACRO
    LODSW
    JMP AX
#EM

VARI    MACRO
    JMP DOVAR
#EM

CONST    MACRO
    JMP DOCON
#EM

TOVAR    MACRO
    JMP DOTOVAR
#EM

VOCAB    MACRO
    JMP DOVOC
#EM

X    MACRO
    XCHG SP,BP
#EM

ORG    0100
    JMP INIT

; STORAGE LOCATIONS FOR USER VARIABLES

CHERE    DW DP
CTOIN    DW 0
CBLOCK    DW 0
CBASE    DW 10
CBLK    DW 0
CSPAN    DW 0
CCOMP    DW 0
CTDP    DW ABORT-6
CS0    DW -256
CR0    DW 0
CDBL    DW 0

TFL    DW 0
CSP    DW 0

BUF:    DB 80        ; TIB FOR KEYBOARD
CNT    DB 81 DUP (0)

; HEADERLESS EXECUTION CODE GOES HERE

DOCOLON:
    X
    PUSH SI
    X
    POP SI
    NEXT
DOTOVAR:
    PUSH BX
    ADD AX,3
    MOV BX,AX
    MOV BX,[BX]
    MOV CX,TFL
    JCXZ FETCH
    OR CX,CX
    MOV W TFL,0
    JNS XSTORE
XPSTORE:
    POP AX
    ADD [BX],AX
    POP BX
    NEXT
XSTORE:
    POP AX
    MOV [BX],AX
    POP BX
    NEXT
DOCON:
    PUSH BX
    ADD AX,3
    MOV BX,AX
FETCH:
    MOV BX,[BX]
    NEXT
DOVAR:
    PUSH BX
    ADD AX,3
    MOV BX,AX
    NEXT
DOVOC:
    ADD AX,3
    MOV W CONT,AX
    NEXT
XEXEC:    MOV AX,BX
    POP BX
    JMP AX
XEXIT:
    X
    POP SI
    X
    NEXT
XTOR:    X
    PUSH BX
    X
    POP BX
    NEXT
XRFR:    PUSH BX
    X
    POP BX
    X
    NEXT
XTOR2:    POP AX
    X
    PUSH BX,AX
    X
    POP BX
    NEXT
XRFR2:    PUSH BX
    X
    POP AX,BX
    X
    PUSH AX
    NEXT
XTO:    INC W TFL
    NEXT
XPTO:    DEC W TFL
    NEXT
XDUP:    PUSH BX
    NEXT
XQDUP:    OR BX,BX
    JNZ XDUP
    NEXT
XDROP:    POP BX
    NEXT
XSWAP:    POP AX
    PUSH BX
    MOV BX,AX
    NEXT
XOVER:    POP AX
    PUSH AX,BX
    MOV BX,AX
    NEXT
XROT:    POP CX,DX
    PUSH CX,BX
    MOV BX,DX
    NEXT
XCAT:    MOV BL,[BX]
    MOV BH,0
    NEXT
XCSTORE:POP AX
    MOV [BX],AL
    POP BX
    NEXT
XDUP2:    PUSH BX
    MOV DI,SP
    PUSH [DI+2]
    NEXT
XDROP2:    POP BX,BX
    NEXT
XSWAP2: POP AX,CX,DX
    PUSH AX,BX,DX
    MOV BX,CX
    NEXT
XPLUS:    POP AX
    ADD BX,AX
    NEXT
XSUBT:    POP AX
    NEG BX
    ADD BX,AX
    NEXT
XZEQ:    XOR AX,AX
    OR BX,BX
    JNZ X1
X2:    DEC AX
X1:    XCHG AX,BX
    NEXT
XZLESS:    XOR AX,AX
    OR BX,BX
    JNS X1
    JS X2
XZGRT:    XOR AX,AX
    OR BX,BX
    JZ X1
    JS X1
    JMP X2
XZNE:    MOV AX,-1
    OR BX,BX
    JZ >L0
    MOV BX,AX
L0:    NEXT
XPLOOP:    X
    POP AX,CX
    INC AX
    INC CX
    JO EXLP
L1:    PUSH CX,AX
    X
XBRAN:    MOV SI,[SI]
    NEXT
XPPLOOP:
    POP DI
    X
    POP AX,CX
    ADD AX,BX
    ADD CX,BX
    MOV BX,DI
    JNO L1
EXLP:    X
L3:    ADD SI,2
    NEXT
XZBRAN:    OR BX,BX
    POP BX
    JZ XBRAN
    JNZ L3
XI:
XRAT:    PUSH BX
    X
    POP BX
    PUSH BX
    X
    NEXT
XOF:    POP AX
    CMP AX,BX
    JZ >L1
    MOV BX,AX
    JMP XBRAN
L1:    POP BX
    ADD SI,2
    NEXT
XOVER2:    POP AX,CX,DX
    PUSH DX,CX,AX,BX,DX
    MOV BX,CX
    NEXT
XONEPL:    INC BX
    NEXT
XTWOPL:    ADD BX,2
    NEXT
XTHREEPL:
    ADD BX,3
    NEXT
XONEMI:    DEC BX
    NEXT
XTWOMI:    SUB BX,2
    NEXT
XTHREEMI:SUB BX,3
    NEXT
XTWOSLS:SAR BX,1
    NEXT
XTWOSTAR:
    SHL BX,1
    NEXT
XUMSTAR:POP AX
    MUL BX
    PUSH AX
    MOV BX,DX
    NEXT
XUMSLSM:POP DX
    XOR AX,AX
    CMP DX,BX
    JNB >L0
    POP AX
    DIV BX
    PUSH DX
L0:    MOV BX,AX
    NEXT
XDPLUS:    POP AX,CX,DX
    ADD DX,AX
    PUSH DX
    ADC BX,CX
    NEXT
XDNEGATE:POP AX
    NEG AX
    PUSH AX
    XCHG AX,BX
    MOV BX,0
    SBB BX,AX
    NEXT
XNEGATE:NEG BX
    NEXT
XAND:    POP AX
    AND BX,AX
    NEXT
XORE:    POP AX
    OR BX,AX
    NEXT
XXORX:    POP AX
    XOR BX,AX
    NEXT
XLIT:    PUSH BX
    LODSW
    MOV BX,AX
    NEXT
XULESS:    POP AX
    SUB AX,BX
    MOV BX,-1
    JB >L0
    INC BX
L0:    NEXT
XLESS:    POP AX
    SUB AX,BX
    MOV BX,-1
    JL  >L0
    INC BX
L0:    NEXT
XTWOAT:    PUSH [BX+2]
    MOV BX,[BX]
    NEXT
XTWOSTORE:POP [BX]
    POP [BX+2]
    POP BX
    NEXT
XPICK:    SHL BX,1
    ADD BX,SP
    MOV BX,[BX]
    NEXT
XEQUAL:    POP AX
    CMP BX,AX
    MOV BX,-1
    JZ >L0
    INC BX
L0:    NEXT
XCR:    MOV DL,0D
    MOV AH,2
    INT 021
    MOV DL,0A
    INT 021
    NEXT
XQKEY:    PUSH BX
    MOV AH,0B
    INT 021
    CBW
    MOV BX,AX
    NEXT
XKEY:    PUSH BX
    MOV AH,7
    INT 021
    XOR AH,AH
    MOV BX,AX
    NEXT
XEMIT:    MOV DL,BL
    MOV AH,2
    INT 021
    POP BX
    NEXT
XTYPE:    POP DX
    MOV CX,BX
    JCXZ >L0
    MOV AH,040
    MOV BX,1
    INT 021
L0:    POP BX
    NEXT

LINK=0
    ; START OF MINIFORTH WITH ITS HEADERS
MINE:    DW LINK
    DB 0E4,'MINI'    ; BIT 6 SET FOR IMMEDIATE, BIT 5 FOR VOCABULARY
MINI:    VOCAB
RUTE:    DW LAST        ; HOLDER FOR LAST
    DW MINE        ; VOCABULARY STOPPER
LINK=$-2        ; WORDS LINK INTO ROOT VOCABULARY, 'MINI'.
    HEAD 4,'EXIT'    ; ( 0/0)
EXIT:    JMP XEXIT
    HEAD 1,'!'    ; (2/0)
STORE:    JMP XSTORE
    HEAD 2,'+!'    ; (2/0)
PSTOR:    JMP XPSTORE
    HEAD 1,'@'    ; (1/1)
ATT:    JMP FETCH
    HEAD 2,'>R'    ; (1/0)
TOR:    JMP XTOR
    HEAD 2,'R>'    ; (0/1)
RFR:    JMP XRFR
    HEAD 3,'2>R'    ; (2/0)
TOR2:    JMP XTOR2
    HEAD 3,'2R>'    ; (0/2)
RFR2:    JMP XRFR2
    HEAD 2,'to'    ; (1/0)
TO:    JMP XTO
    HEAD 3,'+to'    ; (1/0)
PTO:    JMP XPTO
    HEAD 3,'DUP'    ; (1/2)
DUPE:    JMP XDUP
    HEAD 4,'?DUP'    ; (1/2/0)
QDUP:    JMP XQDUP
    HEAD 4,'DROP'    ; (1/0)
DROP:    JMP XDROP
    HEAD 4,'SWAP'    ; (2/2)
SWAP:    JMP XSWAP
    HEAD 4,'OVER'    ; (2/3)
OVER:    JMP XOVER
    HEAD 3,'ROT'    ; (3/3)
ROT:    JMP XROT
    HEAD 2,'C@'    ; (1/1)
CAT:    JMP XCAT
    HEAD 2,'C!'    ; (2/0)
CSTORE:    JMP XCSTORE
    HEAD 4,'2DUP'    ; (2/4)
DUP2:    JMP XDUP2
    HEAD 5,'2DROP'    ; (2/0)
DROP2:    JMP XDROP2
    HEAD 5,'2SWAP'    ; (4/4)
SWAP2:    JMP XSWAP2
    HEAD 5,'2OVER'    ; (4/6)
OVER2:    JMP XOVER2
    HEAD 1,'+'    ; (2/1)
PLUS:    JMP XPLUS
    HEAD 1,'-'    ; (2/1)
SUBT:    JMP XSUBT
    HEAD 2,'0='    ; (1/1)
ZEQ:    JMP XZEQ
    HEAD 2,'0<'    ; (1/1)
ZLESS:    JMP XZLESS
    HEAD 2,'0>'    ; (1/1)
ZGRT:    JMP XZGRT
    HEAD 3,'0<>'    ; (1/1)
ZNE:    JMP XZNE
    HEAD 1,'='    ; (2/1)
EQUAL:    JMP XEQUAL
    HEAD 3,'0br'    ; (1/0)
ZBRAN:    JMP XZBRAN
    HEAD 2,'br'    ; (0/0)
BRAN:    JMP XBRAN
    HEAD 2,'lp'    ; (0/0)
PLOOP:    JMP XPLOOP
    HEAD 3,'+lp'    ; (1/0)
PPLOOP: JMP XPPLOOP
    HEAD 1,'I'    ; (0/1)
I:    JMP XI
    HEAD 2,'R@'    ; (0/1)
RAT:    JMP XRAT
    HEAD 2,'of'    ; (2/0/1)
OF:    JMP XOF
    HEAD 2,'1+'    ; (1/1)
ONEPL:    JMP XONEPL
    HEAD 2,'2+'    ; (1/1)
TWOPL:    JMP XTWOPL
    HEAD 2,'3+'    ; (1/1)
THREEPL:JMP XTHREEPL
    HEAD 2,'1-'    ; (1/1)
ONEMI:    JMP XONEMI
    HEAD 2,'2-'    ; (1/1)
TWOMI:    JMP XTWOMI
    HEAD 2,'3-'    ; (1/1)
THREEMI:JMP XTHREEMI
    HEAD 2,'2/'    ; (1/1)
TWOSLS:    JMP XTWOSLS
    HEAD 2,'2*'    ; (1/1)
TWOSTAR:JMP XTWOSTAR
    HEAD 3,'UM*'    ; (2/2)
UMSTAR:    JMP XUMSTAR
    HEAD 6,'UM/MOD'    ; (3/2)
UMSLSM:    JMP XUMSLSM
    HEAD 2,'D+'    ; (4/2)
DPLUS:    JMP XDPLUS
    HEAD 7,'DNEGATE'; (2/2)
DNEGATE:JMP XDNEGATE
    HEAD 6,'NEGATE'    ; (1/1)
NEGATE:    JMP XNEGATE
    HEAD 3,'AND'    ; (2/1)
ANDD:    JMP XAND
    HEAD 2,'OR'    ; (2/1)
ORE:    JMP XORE
    HEAD 3,'XOR'    ; (2/1)
XORX:    JMP XXORX
    HEAD 3,'LIT'    ; (1/0)
LIT:    JMP XLIT
    HEAD 2,'U<'    ; (2/1)
ULESS:    JMP XULESS
    HEAD 1,'<'    ; (2/1)
LESS:    JMP XLESS
    HEAD 2,'2@'    ; (1/2)
TWOAT:    JMP XTWOAT
    HEAD 2,'2!'    ; (3/0)
TWOSTORE:JMP XTWOSTORE
    HEAD 4,'PICK'    ; (1/1)
PICK:    JMP XPICK
    HEAD 2,'CR'    ; (0/0)
CR:    JMP XCR
    HEAD 4,'?KEY'    ; (0/1)
QKEY:    JMP XQKEY
    HEAD 3,'KEY'    ; (0/1)
KEY:    JMP XKEY
    HEAD 4,'EMIT'    ; (1/0)
EMIT:    JMP XEMIT
    HEAD 4,'TYPE'    ; (2/0)
TYPEE:    JMP XTYPE
    HEAD 2,'<>'    ; (2/1)
NEQ:    COLON
    DW EQUAL,ZEQ,EXIT

    HEAD 5,'CMOVE'
CMOVE:    JMP LONG CM1    ; (3/0)
    DW CM2
CM1:    POP DI,AX
    PUSH SI
    MOV SI,AX
    MOV CX,BX
    JCXZ >L0
    REP MOVSB
L0:    POP SI,BX
    NEXT
CM2=$-CM1

    HEAD 1,'0'
ZERO:    CONST        ; (0/1)
    DW 0
    HEAD 1,'1'
ONE:    CONST        ; (0/1)
    DW 1
    HEAD 1,'2'
TWO:    CONST        ; (0/1)
    DW 2
    HEAD 2,'-1'
MIONE:    CONST        ; (0/1)
    DW -1
    HEAD 3,'$40'
H40:    CONST        ; (0/1)
    DW 040
    HEAD 3,'$80'
H80:    CONST        ; (0/1)
    DW 080
    HEAD 2,'1F'
ONEF:    CONST        ; (0/1)
    DW 01F
    HEAD 2,'7F'
SEVENF:    CONST        ; (0/1)
    DW 07F
    HEAD 2,'BL'
BLANK:    CONST        ; (0/1)
    DW 020
    HEAD 4,'ROOT'
ROOT:    CONST         ; (0/1)
    DW RUTE
    HEAD 7,'CURRENT'
CURRENT:VARI        ; (0/1)
    DW RUTE
    HEAD 7,'CONTEXT'
CONTEXT:VARI        ; (0/1)
CONT    DW RUTE

;    : LATEST CURRENT @ @ ;   (0/1)

    HEAD 6,'LATEST'
LATEST:    COLON
    DW CURRENT,ATT,ATT,EXIT

;     : CLATEST CONTEXT @ @ ; (0/1)

    HEAD 7,'CLATEST'
CLATEST:COLON
    DW CONTEXT,ATT,ATT,EXIT

;    : PATCH  1+ DUP >R 2+ - R> ! ;  (2/0)

    HEAD 5,'PATCH'
PATCH:    COLON
    DW ONEPL,DUPE,TOR,TWOPL,SUBT,RFR,STORE,EXIT

    HEAD 3,'>IN'
TOIN:    TOVAR        ; (0/1)
    DW OFFSET CTOIN
    HEAD 4,'HERE'
HERE:    TOVAR        ; (0/1)
    DW OFFSET CHERE
    HEAD 4,'SPAN'
SPAN:    TOVAR        ; (0/1)
    DW OFFSET CSPAN
    HEAD 3,'BLK'
BLK:    TOVAR        ; (0/1)
    DW OFFSET CBLK
    HEAD 5,'BLOCK'
BLOCK:    TOVAR        ; (0/1)
    DW OFFSET CBLOCK
    HEAD 4,'BASE'
BASE:    TOVAR        ; (0/1)
    DW OFFSET CBASE
    HEAD 9,'COMPILING'
COMP:    TOVAR        ; (0/1)
    DW OFFSET CCOMP
    HEAD 3,'TDP'
TDP:    TOVAR        ; (0/1)
    DW OFFSET CTDP
    HEAD 2,'R0'
R0:    TOVAR        ; (0/1)
    DW OFFSET CR0
    HEAD 2,'S0'
S0:    TOVAR        ; (0/1)
    DW OFFSET CS0
    HEAD 3,'DBL'
DBL:    TOVAR        ; (0/1)
    DW OFFSET CDBL


    HEADI 1,'['    ; : [  0 TO COMPILING ; (0/0)
LBRAK:    COLON
    DW ZERO,TO,COMP,EXIT
    HEAD 1,']'
RBRAK:    COLON
    DW MIONE,TO,COMP,EXIT
    HEAD 5,'SPACE'    ; : BL EMIT ; (0/0)
SPACE:    COLON
    DW BLANK,EMIT,EXIT

    HEAD 5,'COUNT'    ; (1/2)
COUNT:    JMP LONG COUNT1
    DW COUNT2
COUNT1:    MOV AX,BX
    INC AX
    PUSH AX
    MOV BL,[BX]
    MOV BH,0
    NEXT
COUNT2=$-COUNT1

;    : .W   HERE COUNT 1F AND TYPE SPACE ; (0/0)

    HEAD 2,'.W'
DOTW:    COLON
    DW HERE,COUNT,ONEF,ANDD,TYPEE,SPACE,EXIT

;    : LL  TDP 2- ;  (0/1)

    HEAD 2,'LL'
LL:    COLON
    DW TDP,TWOMI,EXIT

;    : ?EX  LL @ = ;  (1/1)

    HEAD 3,'?EX'
QEX:    COLON
    DW LL,ATT,EQUAL,EXIT

;     : ILT  R> COUNT 2DUP + >R TYPE ; (0/0)

    HEAD 3,'ILT'
ILT:    COLON
    DW RFR,COUNT,DUP2,PLUS,TOR,TYPEE,EXIT
    HEAD 5,'ALLOT' ; : ALLOT +TO HERE ; (1/0)
ALLOT:    COLON
    DW PTO,HERE,EXIT
    HEAD 1,','    ; : , HERE ! 2 ALLOT ;  (1/0)
COMMA:    COLON
    DW HERE,STORE,TWO,ALLOT,EXIT
    HEAD 2,'C,'    ; : C, HERE C! 1 ALLOT ; (1/0)
CCOMMA:    COLON
    DW HERE,CSTORE,ONE,ALLOT,EXIT
    HEAD 4,'!CSP'    ; (0/0)
STCSP:    JMP LONG STCSP1
    DW STCSP2
STCSP1:    MOV AX,SP
    MOV CSP,AX
    NEXT
STCSP2=$-STCSP1
    HEAD 4,'CSP?'    ; RETURNS 'TRUE' IF CSP <> SP
CSPQ:    JMP LONG CSPQ1    ; (0/1)
    DW CSPQ2
CSPQ1:    MOV AX,SP
    PUSH BX
    XOR BX,BX
    CMP AX,CSP
    JZ >L0
    DEC BX
L0:    NEXT
CSPQ2=$-CSPQ1

;  : ?CSP  CSP? ABORT" Unbalanced" ;  (0/0)

    HEAD 4,'?CSP'
QCSP:    COLON
    DW CSPQ,QER,
    DB 11,' Unbalanced'
    DW EXIT

;      : :,  $E8 C, LIT DOCOLON HERE 2+ - , ; (0/0)

    HEAD 2,':,'
COLCOM: COLON
    DW LIT,0E8,CCOMMA,LIT,DOCOLON,HERE,TWOPL,SUBT,COMMA,EXIT

;     : ?C  COMPILING 0=      (0/0)
;        IF 1 , HERE TO TDP :, !CSP ] THEN ;

    HEAD 2,'?C'
QC:    COLON
    DW COMP,ZEQ,ZBRAN,QC1,ONE,COMMA,HERE,TO,TDP,COLCOM,STCSP,RBRAK
QC1:    DW EXIT

;    : COMPILE  ?C R> DUP @ , 2+ >R ; (0/0)

    HEAD 7,'COMPILE'
COMPILE:COLON
    DW QC,RFR,DUPE,ATT,COMMA,TWOPL,TOR,EXIT

    HEAD 3,'CXR'    ; XOR CHAR AT ADDR WITH BYTE: (ADDR BYTE... )
CXR:    JMP LONG CXR1    ; (2/0)
    DW CXR2
CXR1:    POP DI
    XOR [DI],BL
    POP BX
    NEXT
CXR2=$-CXR1
    HEAD 3,'SP!'    ; (1/0)
SPST:    JMP LONG SPST1
    DW SPST2
SPST1:  POP AX
    MOV SP,BX
    MOV BX,AX
    NEXT
SPST2=$-SPST1
    HEAD 3,'RP!'    ; (1/0)
RPST:    JMP LONG RPST1
    DW RPST2
RPST1:    MOV BP,BX
    POP BX
    NEXT
RPST2=$-RPST1
    HEAD 3,'CLR'
CLR:    COLON        ;  : CLR  S0 SP! ; (0/0)
    DW S0,SPST,EXIT
    HEAD 7,'EXECUTE'
EXECUTE:JMP XEXEC

    HEAD 5,'ERROR'
ERROR:    DB 0E9        ; VECTORED ERROR HANDLER - PRESENTLY CLEARS STACK
    DW CLR-($+2)
;     : HEX  16 TO BASE ;   (0/0)

    HEAD 3,'HEX'
HEXX:    COLON
    DW LIT,16,TO,BASE,EXIT

;       : DECIMAL  10 TO BASE ;  (0/0)

    HEAD 7,'DECIMAL'
DECIM:    COLON
    DW LIT,10,TO,BASE,EXIT


;     : LITERAL  COMPILING         (1/0 COMPILING)
;    IF COMPILE LIT , THEN ;        (0/0 NON-COMPILING)

    HEADI 7,'LITERAL'
LITERAL:COLON
    DW COMP,ZBRAN,LI1,COMPILE,LIT,COMMA
LI1:    DW EXIT

;      : LINK LL CURRENT @ ! ;        (0/0)

    HEAD 4,'LINK'
LYNK:    COLON
    DW LL,CURRENT,ATT,STORE,EXIT

;     : RID  LL TO HERE ;        (0/0)

    HEAD 3,'RID'
RID:    COLON
    DW LL,TO,HERE,EXIT

    HEAD 3,'0TO'    ;  RESET THE 'TO' FLAG TO ZERO (0/0)
ZEROTO:    JMP LONG ZT1
    DW ZT2
ZT1:    MOV W TFL,0
    NEXT
ZT2=$-ZT1


    HEAD 4,'find'        ;    (2/2)
FINDE:    JMP LONG FIND1
    DW FIND2
FIND1:    POP DX            ; ADDRESS OF 'HERE'
    PUSH SI            ; SAVE IP FOR LATER
L0:    MOV BX,[BX]        ; START OF SEARCH
    OR BX,BX        ; DONE IF LINK = 0
    JZ >L2
    MOV DI,DX        ; ADDR TO DI
    MOV SI,BX        ; AND SI
    ADD SI,2        ; STEP TO NAME FIELD
    MOV CL,[SI]        ; NAME LENGTH
    AND CX,01F        ; REDUCED TO 31 MAX BYTES
    CMP CL,[DI]        ; LENGTHS MATCH?
    JNZ L0            ; NO, GET NEXT NAME
    INC SI            ; YES, STEP TO FIRST CHAR IN NAME
    INC DI
    REPZ CMPSB        ; COMPARE THEM
    JNZ L0            ; NO MATCH - GO GET NEXT
    POP CX            ; NAMES HIT! RESTORE SI
    PUSH SI            ; SI = CODE ADDRESS OF WORD
    MOV SI,CX        ; IP ONCE AGAIN = SI
    TEST B[BX+2],040    ; CHACK FOR IMMEDIATE WORD
    MOV BX,-1        ; TRUE FLAG BUT -1
    JZ >L1
    NEG BX            ; TRUE FLAG BUT +1 IF IMMEDIATE
L1:    NEXT            ; ALL DONE
L2:    POP SI            ; DID NOT FIND WORD SO RECOVER IP
    PUSH DX            ; BX = 0 FOR FALSE FLAG, DX = 'HERE'
    NEXT            ; AND WE'RE DONE
FIND2=$-FIND1

    HEAD 2,'.H'    ; PRINT 4 DIGIT UNSIGNED HEX NUMBER AND SPACE
DOTH:    MOV CX,4    ;  (1/0)
    CALL PRH
    POP BX
    NEXT
    HEAD 3,'.HC'    ; PRINT 2 DIGIT UNSGNED HEX NUMBER AND SPACE
DOTHC:    MOV CX,2    ;  (1/0)
    CALL PRH
    POP BX
    NEXT
PRH:    MOV DI,CX
    MOV AX,BX
    MOV BX,16
L0:    XOR DX,DX
    DIV BX
    XCHG AX,DX
    ADD AL,090
    DAA
    ADC AL,040
    DAA
    PUSH AX
    XCHG AX,DX
    LOOP L0
    MOV CX,DI
    MOV AH,2
L1:    POP DX
    INT 021
    LOOP L1
    MOV DL,' '
    INT 021
    RET

    HEAD 5,'DEPTH'    ; RETURN STACK DEPTH   (0/1)
DEPTH:    JMP LONG D1
    DW D2
D1:    PUSH BX
    MOV BX,CS0
    SUB BX,SP
    SAR BX,1
    DEC BX        ; ACCOUNT FOR NUMBER JUST PUSHED
    NEXT
D2=$-D1

    HEAD 4,'BDOS'    ; RUN DOS SERVICE $21
BDOS:    JMP LONG BDOS1    ; ENTER WITH BX,CX,DX AND # ON STACK (4/1)
    DW BDOS2    ; RETURNS FALSE IF NO ERROR - AX,BX,CX,DX
BDOS1:    MOV AX,BX    ; FUNCTION IN AH
    POP BX,CX,DX
    INT 021
    PUSH DX,CX,BX,AX
    MOV BX,0
    JNC >L0
    DEC BX
L0:    NEXT
BDOS2=$-BDOS1

    HEAD 2,'DU'    ; CONVERT STRING AT ADDRESS TO AN (1/3)
DU:    JMP LONG DU1    ; UNSIGNED DOUBLE NUMBER PLUS FLAG
    DW DU2        ; TRUE IF SUCCESSFUL CONVERSION
DU1:    MOV DI,BX
    XOR AX,AX
    MOV DX,AX    ; CLEAR DOUBLE ACCUMULATOR
    MOV CDBL,AX    ; CLEAR DOUBLE PRECISION FLAG
    MOV CX,CBASE    ; CX = NUMBER BASE
L0:    MOV BL,[DI]    ; ASCII CHARACTER TO CONVERT
    MOV BH,0
    SUB BX,030    ; REMOVE ASCII BIAS
    JB EX        ; DONE IF <0
    CMP BX,10
    JB >L1
    SUB BX,7    ; -7 IF >= 10
    CMP BX,10
    JB EX        ; DONE IF < 10
L1:    CMP BX,CX
    JNB EX        ; DONE IF >= BASE
    PUSH BX        ; SAVE NUMBER
    PUSH DX        ; AND MSH OF PRODUCT
    MUL CX
    MOV BX,AX    ; SAVE LSH OF PRODUCT
    POP AX        ; RECOVER MSH OF PRODUCT
    PUSH DX        ; SAVE OVERFLOW
    MUL CX
    POP DX
    ADD DX,AX    ; ADD OVERFLOW TO MSH
    MOV AX,BX    ; RECOVER LSH
    POP BX        ; AND NUMBER
    ADD AX,BX    ; ADD IT IN  16-BIT TO 32-BIT ADD
    ADC DX,0
    INC DI
    JMP L0
EX:    PUSH AX,DX    ; SAVE DOUBLE NUMBER
    MOV BX,-1    ; TRUE FLAG
    CMP B[DI],'.'
    JNZ >L2
    MOV CDBL,BX    ; DOUBLE PRECISION IF DELIMITER IS A PERIOD
    INC DI
L2:    CMP B[DI],' '    ; MUST BE A SPACE FOR VALID NUMBER
    JZ >L3        ; OK
    INC BX        ; FALSE FLAG
L3:    NEXT
DU2=$-DU1

;    : DS COUNT ASCII - = DUP >R 0= + DU    ( 1/3)
;    IF R>  IF DENEGATE -1 THEN
;    ELSE R> DROP 0
;    THEN ;

    HEAD 2,'DS'
DS0:    COLON
    DW COUNT,LIT,02D,EQUAL,DUPE,TOR,ZEQ,PLUS,DU,ZBRAN,DS1
    DW RFR,ZBRAN,DS2,DNEGATE
DS2:    DW MIONE,BRAN,DS3
DS1:    DW RFR,DROP,ZERO
DS3:    DW EXIT

;     : $DS BASE >R COUNT ASCII $ = DUP        ( 1/3)
;    IF HEX THEN 0= + DS R> TO BASE ;

    HEAD 3,'$DS'
HDS:    COLON
    DW BASE,TOR,COUNT,LIT,024,EQUAL,DUPE,ZBRAN,HDS1,HEXX
HDS1:    DW ZEQ,PLUS,DS0,RFR,TO,BASE,EXIT

    HEAD 2,'NU'    ; VECTORED WORD FOR 'NUMBER' INITIALIZED
NU:    DB 0E9
    DW HDS-($+2)    ; TO POINT TO '$DS' FOR HEX ENTRY
    HEAD 2,'??'
QQ:    COLON        ;    : ??  0= IF .W  -1  ABORT" ?" ;  ( 1/0)
    DW ZEQ,ZBRAN,QQ1,DOTW,MIONE,QER
    DB 2,' ?'
QQ1:    DW EXIT

;    : ?NU   NU  ?? ;        ( 1/3/0)

    HEAD 3,'?NU'
QNU:    COLON
    DW NU,QQ,EXIT

     HEAD 3,'KBD'    ; ACCEPT UP TO 80 CHARACTERS FROM THE KEYBOARD
KBD:    JMP LONG KBD1    ; SPAN HOLDS THE ACTUAL COUNT OF KEYSTROKES
    DW KBD2        ;  ( 0/0)
KBD1:    MOV DX,BUF
    MOV AH,10
    INT 021
    MOV AL,CNT B
    CBW
    MOV CSPAN,AX
    NEXT
KBD2=$-KBD1

;     : RF ROOT find ;     ( 1/2)

    HEAD 2,'RF'
RF:    COLON
    DW ROOT,FINDE,EXIT
    HEAD 4,'FIND'
FIND:    DB 0E9        ; 'FIND' VECTORED TO 'RF' INITIALLY
    DW RF-($+2)

;     (1/1) FOR WORD

    HEAD 4,'WORD'    ; GET NEXT WORD FROM INPUT TO 'HERE'. LEAVE
XWORD:    JMP LONG WORD1    ; 'HERE' ON STACK. ALSO ACCEPTS TAB, CR, AND LF
    DW WORD2    ; AS ABSOLUTE DELIMITERS IN ADDITION TO CHAR ON STK
WORD1:    MOV AH,9    ; TAB CHARACTER
    MOV DX,0D0A    ; CR AND LF CHARACTERS
    MOV AL,BL    ; SCAN CHARACTER
    MOV BX,BUF+2    ; START OF KEYBOARD BUFFER
    MOV CX,CBLK W    ; 0 IF KEYBOARD
    JCXZ >L0
    MOV BX,CBLOCK    ; ELSE GET BLOCK ADDRESS
    XOR CX,CX    ; AND SET CX COUNT TO 0
L0:    ADD BX,CTOIN    ; OFFSET INTO BUFFER
    JMP >L1
L2:    INC CX
    INC BX
L1:    CMP [BX],AL
    JZ L2
    CMP [BX],AH
    JZ L2
    CMP [BX],DL
    JZ L2
    CMP [BX],DH
    JZ L2        ; SKIP BUT COUNT LEADING CHARS
    PUSH SI        ; SAVE THE IP
    MOV SI,BX    ; SI -> FIRST CHAR OF WORD
    JMP >L0
L1:    INC CX
    INC BX
L0:    CMP [BX],AH
    JZ >L3
    CMP [BX],DL
    JZ >L3
    CMP [BX],DH
    JZ >L3
    CMP [BX],AL
    JNZ L1        ; SCAN FOR DELIMITER
L3:    INC CX        ; STEP PAST DELIMITER
    ADD CTOIN,CX    ; ADVANCE >IN BY CX
    SUB BX,SI    ; ACTUAL COUNT OF WORD
    MOV CX,BX    ; INTO CX
    MOV DI,CHERE    ; MOVE TO HERE
    MOV BX,DI    ; TOS ALSO = HERE ON EXIT
    MOV AL,CL    ; WORD LENGTH
    STOSB
    REP MOVSB    ; AND STRING MOVED TO HERE
    MOV AL,' '    ; FOLLOWED BY A SPACE
    STOSB
    POP SI        ; RESTORE THE IP
    NEXT
WORD2=$-WORD1

;    : W,  WORD C@ 1+ ALLOT ;  (1/0)

    HEAD 2,'W,'
WCOMMA:    COLON
    DW XWORD,CAT,ONEPL,ALLOT,EXIT

;    : HEAD  LATEST , HERE TO TDP BL W, TDP $80 CXR ; (0/0)

    HEAD 4,'HEAD'
HED:    COLON
    DW LATEST,COMMA,HERE,TO,TDP,BLANK,WCOMMA
    DW TDP,H80,CXR,EXIT

;      : CREATE  HEAD $E9 C, LIT DOVAR HERE 2+ - , ; (0/0)

    HEAD 6,'CREATE'
VCREATE:COLON
    DW HED,LIT,0E9,CCOMMA,LIT,DOVAR,HERE,TWOPL,SUBT,COMMA,EXIT


;     :  :  HEAD :, !CSP ] ;  (0/0)

    HEAD 1,':'
COLN:    COLON
    DW HED,COLCOM,STCSP,RBRAK,EXIT

;   :  ;  IMMEDIATE ?CSP COMPILE EXIT 1 ?EX  (0/0)
;        IF 2 LL !
;        ELSE LINK
;        THEN [ ;

    HEADI 1,';'
SEMI:    COLON
    DW QCSP,COMPILE,EXIT,ONE,QEX,ZBRAN,SE1,TWO,LL,STORE,BRAN,SE2
SE1:    DW LYNK
SE2:    DW LBRAK,EXIT

;   : LOCATE  BL WORD FIND ;   (0/2)

    HEAD 6,'LOCATE'
LOCATE:    COLON
    DW BLANK,XWORD,FIND,EXIT

;    : NUMBER  1+ ?NU COMPILING        ( 1/0 COMPILING)
;    IF DBL    IF SWAP LITERAL LITERAL ( 1/1 NON-COMPILING)
;        ELSE DROP LITERAL
;        THEN
;    ELSE DBL 0= IF DROP THEN
;    THEN ;

    HEAD 6,'NUMBER'
NUMB:    COLON
    DW ONEPL,QNU,COMP,ZBRAN,NN1,DBL,ZBRAN,NN2,SWAP
    DW LITERAL,LITERAL,BRAN,NN4
NN2:    DW DROP,LITERAL,BRAN,NN4
NN1:    DW DBL,ZEQ,ZBRAN,NN4,DROP
NN4:    DW EXIT

;      : BYE   0 EXECUTE ; (0/0)

    HEAD 3,'BYE'
BYE:    COLON
    DW ZERO,EXECUTE,EXIT

;   : INTERPRET COMPILING    (1/0)
;    IF 1+     IF EXECUTE
;        ELSE ,
;        THEN
;    ELSE DROP EXECUTE
;    THEN ;

    HEAD 9,'INTERPRET'
INTERP:    COLON
    DW COMP,ZBRAN,IN1,ONEPL,ZBRAN,IN2,EXECUTE,BRAN,IN3
IN2:    DW COMMA
IN3:    DW BRAN,IN4
IN1:    DW DROP,EXECUTE
IN4:    DW EXIT

;    : RUN     CR BEGIN >IN SPAN <    ( 0/0)
;           WHILE 0TO LOCATE ?DUP
;            IF INTERPRET
;            ELSE NUMBER
;            THEN DEPTH 0< $80 DEPTH < OR ABORT" Stack?"
;           REPEAT
;           2 ?EX     IF TDP EXECUTE RID [ THEN ;

    HEAD 3,'RUN'
RUN:    COLON
    DW CR
RU1:    DW TOIN,SPAN,LESS,ZBRAN,RU4,ZEROTO,LOCATE,QDUP,ZBRAN,RU3
    DW INTERP,BRAN,RU2
RU3:    DW NUMB
RU2:    DW DEPTH,ZLESS,H80,DEPTH,LESS,ORE,QER
    DB 7,' Stack?'
    DW BRAN,RU1
RU4:    DW TWO,QEX,ZBRAN,RU5,TDP,EXECUTE,RID,LBRAK
RU5:    DW EXIT

;    : QUIT R0 RP! [            ( 0/0)
;    BEGIN CR 0 TO BLK KBD 0 TO >IN RUN
;       COMPILING 0= IF ." ok" THEN
;    AGAIN ;

    HEAD 4,'QUIT'
QUIT:    COLON
    DW R0,RPST,LBRAK
QUI:    DW CR,ZERO,TO,BLK,KBD,ZERO,TO,TOIN,RUN,COMP,ZEQ
    DW ZBRAN,QU1,ILT
    DB 3,' ok'
QU1:    DW BRAN,QUI,EXIT

;   : ?ER 0TO            (1/0)
;    IF COMPILING IF RID THEN
;      R> COUNT TYPE ERROR QUIT
;    ELSE R> COUNT + >R
;    THEN ;

    HEAD 3,'?ER'
QER:    COLON
    DW ZEROTO,ZBRAN,QER3,COMP,ZBRAN,QER2,RID
QER2:    DW RFR,COUNT,TYPEE,ERROR,QUIT,BRAN,QER1
QER3:    DW RFR,COUNT,PLUS,TOR
QER1:    DW EXIT

;    : ABORT  [ -1 ABORT" MINIFORTH V1.0 - 8/8/88" ; (0/0)

LAST:    HEAD 5,'ABORT'
ABORT:    COLON
    DW LBRAK,MIONE,QER
    DB CT
CT1:    DB 'MINIFORTH V1.0 - 8/8/88'
CT=$-CT1
    DW EXIT


INIT:    CLD
    XOR AX,AX
    MOV BX,AX
    MOV CR0,AX
    MOV BP,AX
    SUB AX,256
    MOV CS0,AX
    MOV SP,AX
    MOV AX,10
    MOV CBASE,AX
    MOV CCOMP,BX
    MOV SI,ABORT+3
    NEXT
DP=$